home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / ENVIRON.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-05-19  |  30.9 KB  |  996 lines
  1. ;* ENVIRON.ASM
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Borland TASM code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Manipulate Environments    (interpreter support)        *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21. IDEAL
  22. %PAGESIZE    60, 132
  23. MODEL    small
  24. LOCALS    @@
  25.  
  26.     INCLUDE    "scheme.ash"
  27.     INCLUDE    "interprt.ash"
  28.  
  29. CODESEG
  30.  
  31. ;************************************************************************
  32. ;* push environment                 PUSH-ENV   list-of-symbols *
  33. ;*                                    *
  34. ;* Purpose:  Scheme interpreter support to "push" a new rib onto the    *
  35. ;*        current heap allocated environment.            *
  36. ;************************************************************************
  37. PROC    push_env
  38.     get1op
  39.     mov    bx, SIZE ENVDEF-OFFSET (TYPE ENVDEF).parent
  40.     mov    cx, ENVTYPE
  41.     lea    dx, [tmp_reg]
  42.     save    <ax, si>
  43.     call    alloc_block C, dx, cx, bx
  44.  
  45.     restore <ax>            ; fetch pointer to list-of-symbols
  46.     mov    bx, ax
  47.     shl    ax, 1
  48.     add    bx, ax            ; bx <- #constants * 3
  49.     add    bx, [cb_reg.disp]
  50.     mov    ax, [(CODEDEF es:bx).consts.disp]
  51.     mov    dl, [(CODEDEF es:bx).consts.page]
  52.  
  53.     mov    bx, [tmp_reg.page]    ; place previous env pointer in new one,
  54.     mov    di, [tmp_reg.disp]    ; update stack frame's env pointer
  55.     ldpage    es, bx
  56.     mov    si, [frameptr]
  57.     xchg    bl, [s_stack+si.heap.page]
  58.     mov    [(ENVDEF es:di).parent.page], bl
  59.     mov    cx, di
  60.     xchg    cx, [s_stack+si.heap.disp]
  61.     mov    [(ENVDEF es:di).parent.disp], cx
  62.  
  63.     mov    [(ENVDEF es:di).names.page], dl ; put list-of-symbols pointer into new environment data object
  64.     mov    [(ENVDEF es:di).names.disp], ax
  65.  
  66.     mov    [tm2_reg.bpage], NIL_PAGE*2 ; set tm2_reg to initial empty list of values
  67.     mov    [tm2_reg.disp], NIL_DISP
  68.  
  69.     cmp    dl, 0            ; count number of symbols in the list-of-symbols
  70.     je    @@end
  71.     mov    [(ENVDEF es:di).values.page], NIL_PAGE*2 ; nil value list to prevent gc problems
  72.     mov    [(ENVDEF es:di).values.disp], NIL_DISP
  73.     xor    cx, cx
  74.     xor    bx, bx
  75.     mov    bl, dl            ; copy the list-of-symbols pointer
  76.     mov    si, ax
  77. @@next:
  78.     inc    cx            ; increment list length
  79.     ldpage    es, bx            ; follow the cdr field of the linked list
  80.     mov    bl, [(LISTDEF es:si).cdr.page]
  81.     mov    si, [(LISTDEF es:si).cdr.disp]
  82.     cmp    bl, 0            ; end of list?
  83.     jne    @@next
  84.  
  85.     lea    dx, [nil_reg]
  86.     lea    ax, [tm2_reg]
  87. @@cons:
  88.     push    cx dx ax
  89.     call    cons C, ax, ax, dx    ; create value list of nil pointers (linked through car field)
  90.     pop    ax dx cx
  91.     loop    @@cons
  92.  
  93.     mov    bx, [tmp_reg.page]    ; reload environment object pointer
  94.     ldpage    es, bx            ; (may be altered by cons)
  95.     mov    di, [tmp_reg.disp]
  96. @@end:
  97.     mov    al, [tm2_reg.bpage]    ; store pointer to list-of-values in env object
  98.     mov    [(ENVDEF es:di).values.page], al
  99.     mov    ax, [tm2_reg.disp]
  100.     mov    [(ENVDEF es:di).values.disp], ax
  101.     jmp    next_pc
  102. ENDP    push_env
  103.  
  104. ;************************************************************************
  105. ;* hash-environment                 HASH-ENV                    *
  106. ;*                                    *
  107. ;* Purpose:  Scheme interpreter support to return a hashed environment    *
  108. ;*                                                         *
  109. ;************************************************************************
  110. PROC    hash_env
  111.     get1op
  112.     save    <si>
  113.     mov    bx, (HT_SIZE+1) * SIZE POINTER; size of hashed env
  114.     mov    cx, ENVTYPE
  115.     lea    dx, [tmp_reg]
  116.     push    ax
  117.     call    alloc_block C, dx, cx, bx
  118.  
  119.     mov    bx, [tmp_reg.page]
  120.     corpage bx
  121.     call    zero_blk C, bx, [tmp_reg.disp]
  122.     mov    bx, [tmp_reg.page]
  123.     mov    di, [tmp_reg.disp]
  124.     ldpage    es, bx            ; es is address of new environment
  125.     mov    bx, [frameptr]
  126.     mov    al, [s_stack+bx.heap.page] ; point to parent object
  127.     mov    bx, [s_stack+bx.heap.disp]
  128.     mov    [(ENVDEF es:di).parent.page], al
  129.     mov    [(ENVDEF es:di).parent.disp], bx
  130.     pop    di            ; restore register number
  131.     mov    ax, [tmp_reg.page]    ; return tmp_reg
  132.     mov    bx, [tmp_reg.disp]
  133.     mov    [regs+di.bpage], al
  134.     mov    [regs+di.disp], bx
  135.     jmp    next_pc
  136. ENDP    hash_env
  137.  
  138. ;************************************************************************
  139. ;* drop-environment                 DROP-ENV I(number to drop)    *
  140. ;*                                    *
  141. ;* Purpose:  Scheme interpreter support to drop the most recently    *
  142. ;*        allocated rib from the current environment.        *
  143. ;************************************************************************
  144. PROC    drop_env
  145.     get1op
  146.     save    <si>
  147.     mov    cx, ax            ; copy drop count to cx
  148.     mov    di, [frameptr]
  149.     xor    bx, bx
  150.     mov    bl, [s_stack+di.heap.page] ; load environment pointer from
  151.     mov    si, [s_stack+di.heap.disp] ; the current stack frame
  152. @@loop:
  153.     ldpage    es, bx
  154.     mov    bl, [(ENVDEF es:si).parent.page]
  155.     mov    si, [(ENVDEF es:si).parent.disp]
  156.     loop    @@loop
  157.     mov    [s_stack+di.heap.page], bl ; rib into the stack frame
  158.     mov    [s_stack+di.heap.disp], si
  159.     jmp    next_pc
  160. ENDP    drop_env
  161.  
  162. ;************************************************************************
  163. ;*        Macro Support for load/store-environment        *
  164. ;************************************************************************
  165. MACRO    ld_st    @@typerror, @@valuerror
  166.     get2op
  167.     save    <si>
  168.     xor    bh, bh
  169.     mov    bl, al
  170.     lea    di, [regs+bx]
  171.     save    <di>
  172.     mov    bl, ah            ; copy constant number in di
  173.     mov    di, bx
  174.     shl    bx, 1
  175.     add    di, bx            ; di <- constant number * 3
  176.     add    di, [cb_reg.disp]    ; compute address of code block constant
  177.     xor    bh, bh
  178.     mov    bl, [(CODEDEF es:di).consts.page]
  179.     cmp    [ptype+bx], SYMBTYPE    ; it is a symbol, isn't it?
  180.     jne    @@typerror
  181.     mov    cx, bx            ; copy symbol pointer into cx:dx
  182.     mov    dx, [(CODEDEF es:di).consts.disp]
  183.     mov    si, [frameptr]
  184.     mov    bl, [s_stack+si.heap.page] ; load current env pointer in bx:si
  185.     mov    si, [s_stack+si.heap.disp]
  186.     call    srch_all        ; search environment for symbol
  187.     restore <di>
  188.     cmp    bx, 0            ; was symbol found in environment?
  189.     je    @@valuerror
  190.     ldpage    es, bx
  191.     ENDM
  192.  
  193. ;************************************************************************
  194. ;* Load From Environment           LD-ENV     R(dest),C(symbol)    *
  195. ;*                                    *
  196. ;* Purpose:  Scheme interpreter support to load from the current    *
  197. ;*        environment.                        *
  198. ;************************************************************************
  199. PROC    ld_env
  200.     ld_st    @@notsym, @@notfound
  201.     mov    al, [(LISTDEF es:si).cdr.page]
  202.     mov    bx, [(LISTDEF es:si).cdr.disp]
  203.     mov    [(REG di).bpage], al ; store value in destination register
  204.     mov    [(REG di).disp], bx
  205.     jmp    next_pc
  206.  
  207. @@notsym:
  208.     lea    bx, [@@msg]
  209.     jmp    src_err
  210. DATASEG
  211. @@msg    DB    "ld-env", 0
  212. CODESEG
  213.  
  214. @@notfound:
  215.     corpage cx
  216.     push    es            ; saves es over C call
  217.     xor    ax, ax            ; signal current environment being used
  218.     call    sym_undefined C, cx, dx, ax, di
  219.     pop    es
  220.     restore <si>
  221.     sub    si, 3            ; back up to retry the ld/st
  222.     jmp    sch_err
  223. ENDP    ld_env
  224.  
  225. ;************************************************************************
  226. ;* Store Into Environment           ST-ENV    R(value),C(symbol)    *
  227. ;*                                    *
  228. ;* Purpose:  Scheme interpreter support to store into the current    *
  229. ;*        environment.                        *
  230. ;************************************************************************
  231. PROC    st_env
  232.     ld_st    @@notsym, @@notfound
  233.     mov    al, [(REG di).bpage] ; store value into cdr field of cell
  234.     mov    bx, [(REG di).disp]
  235.     mov    [(LISTDEF es:si).cdr.page], al
  236.     mov    [(LISTDEF es:si).cdr.disp], bx
  237.     jmp    next_pc
  238.  
  239. @@notsym:
  240.     lea    bx, [@@msg]
  241.     jmp    src_err
  242. DATASEG
  243. @@msg    DB    "st-env", 0
  244. CODESEG
  245. @@notfound:
  246.     corpage cx
  247.     push    es            ; saves es over C call
  248.     call    not_lexically_bound C, cx, dx
  249.     pop    es
  250.     restore <si>
  251.     sub    si, 3            ; back up to retry the ld/st
  252.     jmp    sch_err
  253. ENDP    st_env
  254.  
  255. ;************************************************************************
  256. ;*                            al        al    ah    *
  257. ;* Define in Environment           DEFINE   R(d=s1),R(s2),R(s3) *
  258. ;*                           s1=sym,s2=val,s3=env/nil *
  259. ;*                                    *
  260. ;* Purpose: Scheme interpreter support to define a symbol in a given    *
  261. ;*        environment. This routine supports the MIT Scheme construct *
  262. ;*        (set! (access sym env) value). In essence, the current env    *
  263. ;*        is searched for sym. If found, then its binding is modified *
  264. ;*        to value. Otherwise, a new binding is added to the current  *
  265. ;*        environment.                        *
  266. ;************************************************************************
  267. PROC    def_env
  268.     get1op
  269.     mov    di, ax            ; get symbol register number in di
  270.     add    di, OFFSET regs
  271.     get2op
  272.     save    <si, di, ax>        ; save loc ptr, dest reg addr, val/env opnds
  273.     mov    bx, [(REG di).page]
  274.     cmp    [ptype+bx], SYMBTYPE    ; is first operand a symbol?
  275.     je    @@typeok
  276. @@error:
  277.     lea    bx, [@@msg]
  278.     jmp    src_err
  279. DATASEG
  280. @@msg    DB    "define-env", 0
  281. CODESEG
  282. @@typeok:
  283.     mov    cx, bx            ; place symbol pointer into cx:dx
  284.     mov    dx, [(REG di).disp]
  285.     mov    bl, ah            ; validate env operand
  286.     mov    si, [regs+bx.disp]    ; load environment pointer into bx:si
  287.     mov    bl, [regs+bx.bpage]
  288.     cmp    [ptype+bx], ENVTYPE    ; is it an environment object?
  289.     je    @@ok
  290.     cmp    bl, 0            ; is it a nil pointer?
  291.     jne    @@error
  292.     mov    si, [frameptr]
  293.     mov    bl, [s_stack+si.heap.page] ; default env to current env
  294.     mov    si, [s_stack+si.heap.disp]
  295. @@ok:
  296.     push    bx si            ; save environment pointer on stack
  297.     call    srch_all
  298.     restore <ax>            ; 2nd and 3rd operands
  299.     cmp    bl, 0            ; was symbol found?
  300.     je    @@bind
  301.     add    sp, 4            ; clean stack
  302.     ldpage    es, bx
  303.     mov    bl, al
  304.     mov    al, [regs+bx.bpage]    ; set cdr of value cell to the
  305.     mov    bx, [regs+bx.disp]    ; contents of the value register
  306.     mov    [(LISTDEF es:si).cdr.page], al
  307.     mov    [(LISTDEF es:si).cdr.disp], bx
  308.     jmp    next_pc
  309.  
  310. @@bind:
  311.     restore <di>            ; restore symbol register address
  312.     pop    [tm2_reg.disp]        ; restore env pointer in local tmp_reg
  313.     pop    [tm2_reg.page]
  314.     mov    bl, al            ; compute value register address
  315.     add    bx, OFFSET regs
  316.     lea    si, [tm2_reg]
  317.     call    bind_it C, di, bx, si
  318.     jmp    next_pc
  319. ENDP    def_env
  320.  
  321. ;************************************************************************
  322. ;* Set Global Environment               SET-GLOB-ENV!   R(value) *
  323. ;*                                    *
  324. ;* Purpose:  Scheme interpreter support to initialize the Global    *
  325. ;*        Environment Register (GNV_reg).                *
  326. ;************************************************************************
  327. PROC    set_gnv
  328.     get1op
  329.     mov    di, ax
  330.     add    di, OFFSET regs        ; compute reg address in di
  331.     mov    ax, [(REG di).disp]; load pointer to new global environment
  332.     mov    bx, [(REG di).page]
  333.     cmp    [ptype+bx], ENVTYPE    ; it's an environment, isn't it?
  334.     jne    @@error
  335.     xchg    [gnv_reg.bpage], bl    ; copy env pointer to GNV_reg
  336.     xchg    [gnv_reg.disp], ax
  337.     mov    [(REG di).bpage], bl ; store previous value of GNV_reg
  338.     mov    [(REG di).disp], ax
  339.     jmp    next
  340.  
  341. @@error:
  342.     save    <si>            ; save the location pointer
  343.     lea    bx, [@@msg]
  344.     jmp    src_err
  345. @@msg    DB    "set-global-env!", 0
  346. ENDP    set_gnv
  347.  
  348. ;************************************************************************
  349. ;*                                 al   ah    *
  350. ;* Load from Global Environment                LD-GLOBAL    R(d),C(s1)    *
  351. ;*                                  s1=symbol    *
  352. ;*                                    *
  353. ;* Purpose:  Scheme interpreter support to retrieve values for symbols    *
  354. ;*        defined in the current global environment.        *
  355. ;*                                    *
  356. ;* Note:  This instruction is an optimization of the LD-ENV operation.    *
  357. ;*        Here, the environment operand defaults to the current    *
  358. ;*        global environment, which is pointer to by GNV_reg.    *
  359. ;************************************************************************
  360. PROC    ld_globl
  361.     get2op
  362.     mov    bl, al
  363.     lea    di, [regs+bx]        ; compute the destination register's address
  364.     save    <si, di>
  365.     mov    bl, ah            ; copy the constant number
  366.     mov    si, bx            ; si <- constant number * 3
  367.     shl    si, 1
  368.     add    si, bx
  369.     add    si, [cb_reg.disp]    ; add in displacement of current code block
  370.     mov    bl, [(CODEDEF es:si).consts.page]
  371.     mov    dx, [(CODEDEF es:si).consts.disp]
  372. in_ld_globl:
  373.     cmp    [ptype+bx], SYMBTYPE    ; it is a symbol, isn't it?
  374.     jne    @@error
  375.     mov    cx, bx
  376.     mov    bl, [gnv_reg.bpage]    ; load pointer to the global environment
  377.     mov    si, [gnv_reg.disp]
  378.     push    cx dx            ; search the global environment for the symbol-- test to see if found
  379.     call    srch_all
  380.     restore <di>
  381.     cmp    bl, 0            ; was symbol found?
  382.     je    @@notfound
  383.     add    sp, 4            ; clean stack
  384.     ldpage    es, bx
  385.     mov    al, [(LISTDEF es:si).cdr.page]
  386.     mov    bx, [(LISTDEF es:si).cdr.disp]
  387.     mov    [(REG di).bpage], al ; copy cdr field of value cell
  388.     mov    [(REG di).disp], bx ; into destination register
  389.     jmp    next_pc
  390. @@error:
  391.     lea    bx, [@@msg]
  392.     jmp    src_err
  393. DATASEG
  394. @@msg    DB    "ld-global", 0
  395. CODESEG
  396. @@notfound:
  397.     pop    dx cx            ; restore symbol pointer
  398.     corpage cx
  399.     lea    ax, [gnv_reg]
  400.     push    es            ; saves es over C call
  401.     call    sym_undefined C, cx, dx, ax, di
  402.     pop    es
  403.     restore <si>
  404.     sub    si, 3            ;  back up location pointer to retry load
  405.     jmp    sch_err
  406. ENDP    ld_globl
  407.  
  408. ;************************************************************************
  409. ;*                                 al   ah    *
  410. ;* Load from Global Environment    (reg operand)   LD-GLOBAL-R  R(d),R(s1)    *
  411. ;*                                  s1=symbol    *
  412. ;*                                    *
  413. ;* Purpose:  Scheme interpreter support to retrieve values for symbols    *
  414. ;*        defined in the current global environment.        *
  415. ;*                                    *
  416. ;* Note:  This instruction is an optimization of the LD-ENV operation.    *
  417. ;*        Here, the environment operand defaults to the current    *
  418. ;*        global environment, which is pointer to by GNV_reg.    *
  419. ;************************************************************************
  420. PROC    ld_globr
  421.     get2op
  422.     mov    bl, al
  423.     lea    di, [regs+bx]
  424.     save    <si, di>
  425.     mov    bl, ah
  426.     mov    dx, [regs+bx.disp]    ; load symbol's displacement & page
  427.     mov    bl, [regs+bx.bpage]
  428.     jmp    in_ld_globl        ; continue process as ld-global
  429. ENDP    ld_globr
  430.  
  431. ;************************************************************************
  432. ;*                              al      ah    *
  433. ;* Define in Global Environment            DEFINE!   R(d=s1),C(s2)    *
  434. ;*                             s1=value,s2=symbol *
  435. ;*                                    *
  436. ;* Purpose:  Scheme interpreter support to assign a variable in the    *
  437. ;*        current "global" environment.                *
  438. ;*                                    *
  439. ;* Note:  This instruction is an optimization of the DEFINE-ENV        *
  440. ;*        operation.  Here, the environment operand defaults to    *
  441. ;*        the current global environment, which is pointed to by    *
  442. ;*        GNV_reg.                        *
  443. ;************************************************************************
  444. PROC    define
  445.     get2op
  446.     mov    bl, ah            ; copy constant number to bx
  447.     xor    ah, ah
  448.     mov    di, ax
  449.     add    di, OFFSET regs        ; and register to di
  450.     save    <si, di>
  451.     mov    si, bx
  452.     shl    si, 1
  453.     add    si, bx            ; si <- constant number * 3
  454.     add    si, [cb_reg.disp]    ; add starting offset of current code block
  455.     mov    bl, [(CODEDEF es:si).consts.page]
  456.     mov    dx, [(CODEDEF es:si).consts.disp]
  457.     cmp    [ptype+bx], SYMBTYPE    ; it is a symbol, isn't it?
  458.     jne    @@error
  459.     mov    cx, bx            ; put symbol pointer into cx:dx
  460.     push    cx dx
  461.     mov    bl, [gnv_reg.bpage]    ; load global environment pointer into bx:si
  462.     mov    si, [gnv_reg.disp]
  463.     call    srch_env
  464.     cmp    bl, 0
  465.     je    @@new
  466.     add    sp, 4            ; correct stack
  467.     restore <di>
  468.     ldpage    es, bx
  469.     mov    al, [(REG di).bpage]
  470.     mov    bx, [(REG di).disp]
  471.     mov    [(LISTDEF es:si).cdr.page], al
  472.     mov    [(LISTDEF es:si).cdr.disp], bx
  473.     jmp    next_pc
  474.  
  475. @@new:                    ; symbol wasn't found. create new binding in current global environment
  476.     mov    ax, sp            ; get address of symbol
  477.  
  478. ;     In case you're wondering what just went on with the above instruction,
  479. ;     the page and displacement of the symbol to be bound are residing in the
  480. ;     correct order on the top of the stack.  The "mov ax,sp" captures the
  481. ;     address of said pointer so that it may be used as an argument to
  482. ;     sym_bind, below.
  483.  
  484.     lea    bx, [gnv_reg]
  485.     call    bind_it C, ax, [(SINT_ARG bp-SIZE SINT_ARG).sv_di], bx
  486. ;    call    bind_it C, ax, [save_di], bx
  487.     add    sp, 4            ; restore stack
  488.     jmp    next_pc
  489.  
  490. @@error:
  491.     lea    bx, [@@msg]
  492.     jmp    src_err
  493. DATASEG
  494. @@msg    DB    "define!", 0
  495. CODESEG
  496. ENDP    define
  497.  
  498. ;************************************************************************
  499. ;*                              al      ah    *
  500. ;* Define in Global Environment            ST-GLOBAL R(d=s1),C(s2)    *
  501. ;*                             s1=value,s2=symbol *
  502. ;*                                    *
  503. ;* Purpose:  Scheme interpreter support to assign a variable in the    *
  504. ;*        current "global" environment.                *
  505. ;*                                    *
  506. ;* Note:  This instruction is an optimization of the ST-ENV        *
  507. ;*        operation.  Here, the environment operand defaults to    *
  508. ;*        the current global environment, which is pointed to by    *
  509. ;*        GNV_reg.                        *
  510. ;************************************************************************
  511. PROC    st_globl
  512.     get2op
  513.     mov    bl, ah            ; copy constant number to bx
  514.     xor    ah, ah
  515.     mov    di, ax
  516.     add    di, OFFSET regs        ; and register to di
  517.     save    <si, di>
  518.     mov    si, bx
  519.     shl    si, 1
  520.     add    si, bx            ; si <- constant number * 3
  521.     add    si, [cb_reg.disp]    ; add starting offset of current code block
  522.     mov    bl, [(CODEDEF es:si).consts.page]
  523.     mov    dx, [(CODEDEF es:si).consts.disp]
  524.     cmp    [ptype+bx], SYMBTYPE    ; it is a symbol, isn't it?
  525.     jne    @@error
  526.     mov    cx, bx            ; put symbol pointer into cx:dx
  527.     push    cx dx
  528.     mov    bl, [gnv_reg.bpage]
  529.     mov    si, [gnv_reg.disp]
  530.     call    srch_all
  531.     restore <di>
  532.     cmp    bl, 0
  533.     je    @@notfound
  534.     add    sp, 4            ; clean stack
  535.     ldpage    es, bx
  536.     mov    al, [(REG di).bpage]
  537.     mov    bx, [(REG di).disp]
  538.     mov    [(LISTDEF es:si).cdr.page], al
  539.     mov    [(LISTDEF es:si).cdr.disp], bx
  540.     jmp    next_pc
  541. @@notfound:
  542.     pop    dx cx
  543.     corpage cx
  544.     push    es            ; saves es over C call
  545.     call    not_globally_bound C, cx, dx, di
  546.     pop    es
  547.     restore <si>
  548.     sub    si, 3            ; back up pointer up to retry the store
  549.     jmp    sch_err
  550. @@error:
  551.     lea    bx, [@@msg]
  552.     jmp    src_err
  553. DATASEG
  554. @@msg    DB    "st-global", 0
  555. CODESEG
  556. ENDP    st_globl
  557.  
  558. ;************************************************************************
  559. ;* Environment Predicate                ENV?    object  *
  560. ;*                                    *
  561. ;* Purpose:  Scheme interpreter support to test for an environment    *
  562. ;*        data object.                        *
  563. ;************************************************************************
  564. PROC    env_p
  565.     get1op
  566.     mov    di, ax
  567.     add    di, OFFSET regs
  568.     mov    bx, [(REG di).page]
  569.     cmp    [ptype+bx], ENVTYPE    ; is operand an environment?
  570.     je    @@itis
  571.     mov    [(REG di).bpage], NIL_PAGE*2
  572.     mov    [(REG di).disp], NIL_DISP
  573.     jmp    next
  574. @@itis:
  575.     mov    [(REG di).bpage], T_PAGE*2
  576.     mov    [(REG di).disp], T_DISP
  577.     jmp    next            ; return to interpreter
  578. ENDP    env_p
  579.  
  580. ;************************************************************************
  581. ;* Make Environment                    MK-ENV       dest *
  582. ;*                                    *
  583. ;* Purpose:  Scheme interpreter support to return a pointer to the    *
  584. ;*        current environment.                    *
  585. ;************************************************************************
  586. PROC    mk_env
  587.     get1op
  588.     mov    di, ax
  589.     mov    bx, [frameptr]
  590.     mov    al, [s_stack+bx.heap.page] ; load current env pointer from stack
  591.     mov    bx, [s_stack+bx.heap.disp]
  592.     mov    [regs+di.bpage], al    ; and put in destination register
  593.     mov    [regs+di.disp], bx
  594.     jmp    next
  595. ENDP    mk_env
  596.  
  597. ;************************************************************************
  598. ;* Environment Parent                    ENV-PARENT  env *
  599. ;*                                    *
  600. ;* Purpose:  Scheme interpreter return the "parent" of a given        *
  601. ;*        environment.                        *
  602. ;************************************************************************
  603. PROC    env_par
  604.     get1op
  605.     save    <si>
  606.     mov    di, ax
  607.     add    di, OFFSET regs
  608.     mov    bx, [(REG di).page]
  609.     cmp    [ptype+bx], ENVTYPE
  610.     jne    @@error
  611.     mov    si, [(REG di).disp] ; load pointer to environment object
  612.     ldpage    es, bx
  613.     mov    al, [(ENVDEF es:si).parent.page] ; load parent pointer from env object
  614.     mov    bx, [(ENVDEF es:si).parent.disp]
  615.     mov    [(REG di).bpage], al ;  and put in destination register
  616.     mov    [(REG di).disp], bx
  617.     jmp    next_pc
  618. @@error:
  619.     lea    bx, [@@msg]
  620.     jmp    src_err
  621. DATASEG
  622. @@msg    DB    "environment-parent", 0
  623. CODESEG
  624. ENDP    env_par
  625.  
  626. ;************************************************************************
  627. ;* Lookup In Environment            ENV-LU      R(d=s1),R(s2)    *
  628. ;*                               s1=symbol,s2=env    *
  629. ;************************************************************************
  630. PROC    env_lu
  631.     get2op
  632.     xor    bh, bh            ; fetch and validate symbol pointer
  633.     mov    bl, al
  634.     lea    di, [regs+bx]
  635.     save    <si, di>
  636.     mov    cx, [(REG di).page]; copy symbol pointer into cx:dx
  637.     mov    dx, [(REG di).disp]
  638.     mov    bx, cx            ; test to make sure that first operand
  639.     cmp    [ptype+bx], SYMBTYPE    ;  is a symbol
  640.     jne    @@error
  641.     mov    bl, ah            ; fetch and validate environment pointer
  642.     mov    si, [regs+bx.disp]    ; copy environment pointer into bx:si
  643.     mov    bl, [regs+bx.bpage]
  644.     cmp    [ptype+bx], ENVTYPE    ; it is an env, isn't it?
  645.     jne    @@error
  646.     call    srch_all
  647.     restore <di>
  648.     mov    [(REG di).bpage], bl
  649.     mov    [(REG di).disp], si
  650.     jmp    next_pc
  651. @@error:
  652.     lea    bx, [@@msg]
  653.     jmp    src_err
  654. DATASEG
  655. @@msg    DB    "env-lu", 0
  656. CODESEG
  657. ENDP    env_lu
  658.  
  659. ;************************************************************************
  660. ;*        Local Support - Search Environment (all of it)        *
  661. ;*                                    *
  662. ;* Input Parameters:  cx:dx - search symbol                *
  663. ;*              bx:si - environment chain pointer            *
  664. ;*                                    *
  665. ;* Output Parameters: bx:si - value cell for symbol            *
  666. ;* trashes: cx, dx                            *
  667. ;************************************************************************
  668. PROC    srch_all near
  669. @@loop:
  670.     push    bx si cx dx        ; save pointer to current rib
  671.     call    srch_env        ; search rib for desired symbol
  672.     cmp    bx, 0            ; was symbol found?
  673.     jne    @@done
  674.     pop    dx cx si bx        ; restore pointer to current rib
  675.     ldpage    es, bx
  676.     mov    bl, [(ENVDEF es:si).parent.page]
  677.     mov    si, [(ENVDEF es:si).parent.disp]
  678.     cmp    bx, 0            ; does parent rib exist?
  679.     jne    @@loop
  680.     jmp    @@fail
  681. @@done:
  682.     add    sp, 8            ; dump env pointer off stack
  683. @@fail:
  684.     ret
  685. ENDP    srch_all
  686.  
  687. ;************************************************************************
  688. ;*        Local Support - Search Environment (one rib)        *
  689. ;*                                    *
  690. ;* Input Parameters:  cx:dx - search symbol                *
  691. ;*              bx:si - environment chain pointer            *
  692. ;*                                    *
  693. ;* Output Parameters: bx:si - value cell for symbol            *
  694. ;************************************************************************
  695. PROC    srch_env near
  696.     ldpage    es, bx
  697.     cmp    [(ENVDEF es:si).len], SIZE ENVDEF ; hash table or "rib"?
  698.     je    @@rib
  699.     jmp    @@hashtable
  700. @@rib:
  701.     push    bx si            ; save pointer to environment
  702.     mov    ax, 1            ; initialize counter
  703.     xor    bx, bx
  704.     mov    bl, [(ENVDEF es:si).names.page] ; load pointer to list of symbols
  705.     mov    si, [(ENVDEF es:si).names.disp]
  706. @@ribmore:
  707.     cmp    bl, 0            ; more symbols in this rib?
  708.     je    @@ribnotfound
  709.     ldpage    es, bx
  710.     cmp    dx, [(LISTDEF es:si).car.disp]
  711.     jne    @@ribnext
  712.     cmp    cl, [(LISTDEF es:si).car.page]
  713.     je    @@ribfound
  714. @@ribnext:
  715.     inc    ax            ; increment symbol count
  716.     mov    bl, [(LISTDEF es:si).cdr.page]
  717.     mov    si, [(LISTDEF es:si).cdr.disp]
  718.     jmp    @@ribmore
  719. @@ribfound:
  720.     mov    cx, ax            ; move counter symbol counter to cx
  721.     pop    si bx            ; recover pointer to environment chain
  722.     ldpage    es, bx
  723.     mov    bl, [(ENVDEF es:si).values.page]
  724.     mov    si, [(ENVDEF es:si).values.disp]
  725.     jmp    @@ribskip
  726. @@ribloop:
  727.     ldpage    es, bx            ; follow chain through car field of linked list
  728.     mov    bl, [(LISTDEF es:si).car.page]
  729.     mov    si, [(LISTDEF es:si).car.disp]
  730. @@ribskip:
  731.     loop    @@ribloop
  732.     ret
  733.  
  734. @@ribnotfound:
  735.     add    sp, 4            ; drop env pointer off stack
  736.     ret
  737.  
  738. ;************************************************************************
  739. ;*            Hash Table Environment Format            *
  740. ;************************************************************************
  741. @@hashtable:
  742. DATASEG
  743. @@temp    REG <>
  744. CODESEG
  745.     push    bx
  746.     mov    [@@temp.page], cx    ; store symbol pointer in tmp_reg
  747.     mov    [@@temp.disp], dx
  748.     lea    ax, [@@temp]
  749.     call    sym_hash C, ax
  750.     cmp    ax, HT_SIZE        ; valid hash value returned?
  751.     jae    @@hasherror
  752.     pop    bx            ; restore pointer to environment object
  753.     add    si, ax            ; env-ptr += hash-value * 3
  754.     shl    ax, 1            ; fetch symbol chain from indicated hash table bucket
  755.     add    si, ax
  756.     ldpage    es, bx            ; load environment page's paragraph address
  757.     mov    bl, [(ENVDEF es:si).names.page]
  758.     cmp    bl, 0            ; is hash chain empty?
  759.     je    @@hashnotfound
  760.     mov    si, [(ENVDEF es:si).names.disp]
  761.     ldpage    es, bx
  762.     mov    dx, [@@temp.page]    ; restore symbol pointer into dx:ax
  763.     mov    ax, [@@temp.disp]
  764.     call    lookup
  765.     mov    si, di            ; put pointer returned in bx:si
  766.     ret
  767.  
  768. @@hasherror:
  769.     add    sp, 4            ; drop saved arguments off stack
  770.     xor    bx, bx            ; return a nil pointer
  771. @@hashnotfound:
  772.     xor    si, si
  773.     ret
  774. ENDP    srch_env
  775.  
  776. ;************************************************************************
  777. ;*            Symbol Binding Routine                *
  778. ;*                                    *
  779. ;* Purpose:  Borland C callable routine to return the bind a value to    *
  780. ;*        a symbol in a given environment.            *
  781. ;*                                    *
  782. ;* Calling Sequence:  sym_bind(symbol, value, environment)        *
  783. ;*            where symbol - register containing the symbol    *
  784. ;*                    pointer                *
  785. ;*                   value - register containing the value to *
  786. ;*                    be assigned            *
  787. ;*             environment - register containing a pointer to *
  788. ;*                    the environment in which the    *
  789. ;*                    binding is to take place    *
  790. ;************************************************************************
  791. PROC C    sym_bind far USES si di, @@symbol, @@value, @@env
  792.     mov    bx, [@@symbol]
  793.     mov    cx, [(REG bx).page]
  794.     mov    dx, [(REG bx).disp]
  795.     mov    bx, [@@env]
  796.     mov    si, [(REG bx).disp]
  797.     mov    bx, [(REG bx).page]
  798.     call    srch_all
  799.     cmp    bl, 0            ; symbol found in environment?
  800.     je    @@new
  801.     ldpage    es, bx
  802.     mov    bx, [@@value]
  803.     mov    al, [(REG bx).bpage]    ; copy value from value register
  804.     mov    bx, [(REG bx).disp]
  805.     mov    [(LISTDEF es:si).cdr.page], al ; into the cdr field of the value cell
  806.     mov    [(LISTDEF es:si).cdr.disp], bx
  807.     jmp    @@ret
  808.  
  809. in_sym_bind:
  810. @@new:
  811.     mov    si, [@@env]
  812.     mov    bx, [(REG si).page]
  813.     mov    si, [(REG si).disp]
  814.     ldpage    es, bx
  815.     cmp    [(ENVDEF es:si).len], SIZE ENVDEF
  816.     je    @@rib
  817.     jmp    @@hashtable
  818. @@rib:
  819. ;************************************************************************
  820. ;*        bind symbol to "rib" format environment            *
  821. ;************************************************************************
  822.     mov    al, [(ENVDEF es:si).names.page]
  823.     mov    bx, [(ENVDEF es:si).names.disp]
  824.     mov    [tmp_reg.bpage], al
  825.     mov    [tmp_reg.disp], bx
  826.     lea    ax, [tmp_reg]
  827.     call    cons C, ax, [@@symbol], ax ; cons symbol to front of name list
  828.     mov    bx, [@@env]
  829.     mov    si, [(REG bx).disp]    ; it may have been relocated during the the cons
  830.     mov    bx, [(REG bx).page]
  831.     ldpage    es, bx
  832.     mov    al, [tmp_reg.bpage]    ; update name list pointer
  833.     mov    bx, [tmp_reg.disp]
  834.     mov    [(ENVDEF es:si).names.page], al
  835.     mov    [(ENVDEF es:si).names.disp], bx
  836.  
  837.     mov    al, [(ENVDEF es:si).values.page]
  838.     mov    bx, [(ENVDEF es:si).values.disp]
  839.     mov    [tmp_reg.bpage], al
  840.     mov    [tmp_reg.disp], bx
  841.     lea    ax, [tmp_reg]
  842.     call    cons C, ax, ax, [@@value] ; cons value to front of value list
  843.     mov    bx, [@@env]
  844.     mov    si, [(REG bx).disp]
  845.     mov    bx, [(REG bx).page]
  846.     ldpage    es, bx
  847.     mov    al, [tmp_reg.bpage]
  848.     mov    bx, [tmp_reg.disp]
  849.     mov    [(ENVDEF es:si).values.page], al
  850.     mov    [(ENVDEF es:si).values.disp], bx
  851.     jmp    @@ret
  852. ;************************************************************************
  853. ;*        bind symbol to "hash table" format environment        *
  854. ;************************************************************************
  855. @@hashtable:
  856.     lea    ax, [tmp_reg]
  857.     call    cons C, ax, [@@symbol], [@@value]
  858.     lea    ax, [tmp_reg]
  859.     lea    bx, [nil_reg]
  860.     call    cons C, ax, ax, bx
  861.     call    sym_hash C, [@@symbol]
  862.     mov    bx, ax            ; multiply hash value by 3
  863.     shl    ax, 1
  864.     add    bx, ax
  865.     mov    si, [@@env]
  866.     add    bx, [(REG si).disp]
  867.     mov    si, [(REG si).page]
  868.     ldpage    es, si
  869.     mov    ax, [tmp_reg.page]    ; load pointer to second list cell
  870.     mov    dx, [tmp_reg.disp]
  871.     mov    si, ax
  872.     mov    di, dx
  873.     xchg    al, [(ENVDEF es:bx).names.page] ; swap list header in environment hash
  874.     xchg    dx, [(ENVDEF es:bx).names.disp]
  875.     ldpage    es, si
  876.     mov    [(LISTDEF es:di).cdr.page], al    ; update entry in env hash table
  877.     mov    [(LISTDEF es:di).cdr.disp], dx
  878. @@ret:
  879.     ret
  880. ENDP    sym_bind
  881.  
  882. ;************************************************************************
  883. ;*            Symbol Forced Binding Routine            *
  884. ;* (a shortcut in sym_bind)                        *
  885. ;*                                    *
  886. ;* !!! This procedure HAS to have the same parameters as the previous    *
  887. ;************************************************************************
  888. PROC C    bind_it    far USES si di, @@symbol, @@value, @@env
  889.     jmp    in_sym_bind
  890. ENDP    bind_it
  891.  
  892. ;************************************************************************
  893. ;*            eq_lookup Routine                *
  894. ;*                                    *
  895. ;* Borland C callable routine to simulate a lookup for a pointer in a     *
  896. ;* list of pairs (ASSQ)                            *
  897. ;*                                    *
  898. ;* Calling Sequence:  eq_lookup(item, list)                *
  899. ;*            where    item - register containing the object    *
  900. ;*                    to seek,            *
  901. ;*                list - register containing a pointer to *
  902. ;*                    the list of pairs to be searched*
  903. ;*                                    *
  904. ;* It points item to the pair (item . value) and return true if found,    *
  905. ;* or leave item unchanged and return false.                *
  906. ;************************************************************************
  907. PROC C    eq_lookup far USES si di, @@item, @@list
  908.     mov    si, [@@item]
  909.     mov    di, [@@list]
  910.     mov    ax, [(REG si).disp]
  911.     mov    dx, [(REG si).page]
  912.     mov    bx, [(REG di).page]
  913.     mov    si, [(REG di).disp]
  914.     call    lookup            ; search
  915.     xor    ax, ax            ; assume not found
  916.     or    bl, bl            ; bl = 0 if not found
  917.     jz    @@return
  918.     inc    ax            ; return true
  919.     mov    si, [@@item]
  920.     mov    [(REG si).disp], di
  921.     mov    [(REG si).bpage], bl
  922. @@return:
  923.     ret
  924. ENDP    eq_lookup
  925.  
  926. ;************************************************************************
  927. ;*            Symbol Lookup Routine                *
  928. ;*                                    *
  929. ;* Purpose:  Borland C callable routine to return the value bound to    *
  930. ;*        a symbol in a given environment.            *
  931. ;*                                    *
  932. ;* Calling Sequence:  sym_lookup(symbol, environment)            *
  933. ;*            where symbol - register containing the symbol    *
  934. ;*                    pointer                *
  935. ;*             environment - register containing a pointer to *
  936. ;*                    the environment to be searched    *
  937. ;************************************************************************
  938. PROC C    sym_lookup far USES si di, @@symbol, @@env
  939.     mov    bx, [@@symbol]
  940.     mov    cx, [(REG bx).page]
  941.     mov    dx, [(REG bx).disp]
  942.     mov    bx, [@@env]
  943.     mov    si, [(REG bx).disp]
  944.     mov    bx, [(REG bx).page]
  945.     call    srch_all
  946.     xor    ax, ax            ; assume search failed
  947.     or    bl, bl            ; symbol found in environment?
  948.     jz    @@ret
  949.     ldpage    es, bx
  950.     mov    bx, [@@symbol]
  951.     mov    al, [(LISTDEF es:si).cdr.page]    ; copy current binding into the
  952.     mov    cx, [(LISTDEF es:si).cdr.disp]
  953.     mov    [(REG bx).bpage], al    ; argument register
  954.     mov    [(REG bx).disp], cx
  955.     mov    ax, 1            ; return true
  956. @@ret:
  957.     ret
  958. ENDP    sym_lookup
  959.  
  960. ;************************************************************************
  961. ;*            Symbol Hashing Routine                *
  962. ;*                                    *
  963. ;* Purpose:  Borland C callable routine to return the hash value for    *
  964. ;*        a given symbol.                        *
  965. ;*                                    *
  966. ;* Calling Sequence:  hash = sym_hash(reg)                *
  967. ;*            reg  - register containing symbol pointer    *
  968. ;*            hash - the hash value (if page/disp don't point *
  969. ;*                to a symbol, -1 is returned)        *
  970. ;*                                    *
  971. ;* Methods Used:  The hash value is computed by summing the characters    *
  972. ;*        of the symbol and returning the remainder on division    *
  973. ;*        by the length of the hash table (HT_SIZE).        *
  974. ;*                                    *
  975. ;* Note:  This routine must return the same hash value as the routine    *
  976. ;*        "hash" in SUPPORT.C.  If the hashing algorithm is    *
  977. ;*        changed, it must be changed in both routines.        *
  978. ;************************************************************************
  979. PROC C    sym_hash far USES di si, @@reg
  980.     mov    di, [@@reg]
  981.     mov    bx, [(REG di).page]
  982.     cmp    [ptype+bx], SYMBTYPE    ; is object a symbol?
  983.     jne    @@error
  984.     ldpage    es, bx
  985.     mov    si, [(REG di).disp]
  986.     xor    ah, ah            ; fetch the symbol's hash key
  987.     mov    al, [(SYMDEF es:si).hashkey]
  988. @@ret:
  989.     ret
  990. @@error:
  991.     mov    ax, -1            ; return a hash value of -1 (invalid)
  992.     jmp    @@ret
  993. ENDP    sym_hash
  994.  
  995.     END
  996.